









;================
;=              =
;=    pFORTH    =
;=              =
;================
;
; 
; registers in use:
;  HL ... top of stack
;  DE ... work register
;  BC ... program counter
;  IX ... return stack
;  SP ... stack register
;  AF ... work and flags
;  IY ... jumptable pointer
;
;
;
;
; 'benchmark'
;
;  LET x = 0            ld a, 100                     32768       addr      
;  FOR i = 1 TO 100	ld de, 0                      0           addr sum
;  LET x = x + a[i]     ld hl, 32768                  100         addr sum loopcount
;  NEXT i             loop:                           DO          addr sum
;                       ld c, (hl)     7                SWAP      sum addr            48
;                       inc l          4                INC       sum addr+1          35        
;                       ld b, (hl)     7                INC       sum addr+2          35
;                       inc l          4                SWAP      addr+2 sum          48
;                       ex de, hl      4                OVER      addr+2 sum addr+2   65
;                       add hl, bc     11               FETCH     addr+2 sum [addr+2] 65
;                       ex de, hl      4                PLUS      addr+2 sum          62
;                       dec a          4              LOOP                            180
;                       jp nz, loop    10 55          SWAP        sum addr            538*100 = 53800
;                                      55*100 = 5500  DROP        sum                
;  
;  cca 10 times slower than pure asm
;
;
	.MODULE pforth

;	TOKEN TABLE


_forthtab
	; 000 EXIT     leave forth
	; 003 SWAP     x1 x2 -- x2 x1
	; 011 DUP      x1 -- x1 x1
	; 019 DROP     x1 -- 
	; 026 INC      x1 -- x1+1
	; 033 DEC      x1 -- x1-1
	; 040 OVER     x1 x2 -- x1 x2 x1
	; 050 ROT      x1 x2 x3 -- x2 x3 x1
	; 061 PLUS     x1 x2 -- x1+x2
	; 069 MINUS
	 

	jp _exit	;000 EXIT
			
	ex (hl), sp	;003 SWAP 48T
	ld a, (bc)	;SWAP x1 x2 -- x2 x1
	inc bc
	ld ly, a
	jp (iy)

	push hl		;011 DUP 40T
	ld a, (bc)	;DUP x1 -- x1 x1
	inc bc
	ld ly, a
	jp (iy)

	pop hl		;019 DROP 39T
	ld a, (bc)	;DROP x1 --
	inc bc
	ld ly, a
	jp (iy)

	inc hl		;026 INC 35T
	ld a, (bc)	;INC x1 -- x2  x2=x1+1
	inc bc
	ld ly, a
	jp (iy)

	dec hl		;033 DEC 35T
	ld a, (bc)	;DEC x1 -- x2  x2=x1-1	
	inc bc
	ld ly, a
	jp (iy)

	pop de		;040 OVER 65T
	push de		;OVER x1 x2 -- x1 x2 x1
	push hl
	ex de, hl
	ld a, (bc)	
	inc bc
	ld ly, a
	jp (iy)
	
	pop de		;050 ROT 44T
	ex de, hl	;ROT x1 x2 x3 -- x2 x3 x1
	ex (sp), hl
	push de
	ld a, (bc)	
	inc bc
	ld ly, a
	jp (iy)
	
	pop de		;061 PLUS 40T
	add hl, de	;PLUS x1 x2 -- x3 x3=x1+x2
	ld a, (bc)	
	inc bc
	ld ly, a
	jp (iy)
	

	pop de		;069 MINUS 
	ex de, hl	;MINUS x1 x2 -- x3 x2=z1-x2
	or a
	sbc hl, de
	ld a, (bc)	
	inc bc
	ld ly, a
	jp (iy)
				

	ld a, h		;080 ISZERO
	or l		;ISZERO x1 -- (x1==0)?TRUE:FALSE
	jp z, next
	dec hl
	jp _next


	ld a, (bc)	;089 CALL
	ld e, a		;CALL   --  
	inc bc
	ld a, (bc)
	inc bc
	dec ix
	dec ix
	ld (ix + 0), c
	ld (ix + 1), b
	ld b, a
	ld c, e
	jp _next	

	ld c, (ix + 0)	;109 RETURN
	ld b, (ix + 1)	;RETURN    --
	inc ix
	inc ix
	jp _next 	

	jp _f_do	;xxx DO

	jp _f_loop	;xxx LOOP

	jp _f_i		;xxx I
	
	jp _f_j		;xxx J

	jp _f_leave	;xxx LEAVE

	jp _f_brzero	;xxx 0 = BRANCH      (aka BRANCH FALSE aka IF)

	jp _f_brnz	;xxx 0 != BRANCH     (aka BRANCH TRUE)

	jp _f_and	;xxx AND

	jp _f_or	;xxx OR

	jp _f_xor	;xxx XOR

	jp _f_not	;xxx NOT

	jp _f_sign	;xxx SIGN (x1<0)?TRUE:FALSE

	jp _f_neg	;xxx NEG

	jp _f_eq	;xxx EQ (x1==x2)?TRUE:FALSE

	jp _f_less	:xxx LESS (x1<x2)?TRUE:FALSE
	
	jp _f_more	;xxx MORE (x1>x2)?TRUE:FALSE
	
	jp _f_neq	;xxx NEQ

	jp _f_eqless

	jp _f_eqmore

	jp _f_mul

	jp _f_div

	jp _f_shiftl

	jp _f_shiftr

	jp _f_2r

	jp _f_r2

	jp _f_fetchr

	

pforth
	;entry point for pforth
	;BC = program to interpreter
	push ix
	push iy
	push hl
	push de
	push af
	ld hy, _forthtab / 256

	;main loop 29T(next) + 10T(table jp) + 12T(return jp)
_next
	ld a, (bc)
	inc bc
	ld ly, a
	jp (iy)

_exit 
	pop af
	pop de
	pop hl
	pop iy
	pop ix
	ret
		
_f_var
	;VARIABLE
	

_f_store
	;STORE
	;
	pop de
	ld (hl), e
	inc hl
	ld (hl), d
	pop hl
	jr _next

_f_fetch
	;FETCH
	;7B 24T + 12 + 29 
	ld e, (hl)
	inc hl
	ld d, (hl)
	ex de, hl
	jr _next

_f_num
	;NUMBER
	;
	push hl
	ld a, (bc)
	inc bc
	ld l, a
	ld a, (bc)
	inc bc
	ld h, a
	jp _next

_f_loop
	;
	ld e, (ix + 0)	;15
	ld d, (ix + 1)	;15 DE = index
	ld a, d		;4
	cp (ix + 3)	;15
	jr c, _f_loop_2	;7 (limit/256 > index/limit)
	ld a, e		;4
	cp (ix + 4)	;15
	jr nc, _f_loop1 ;7 (limit <= index )	
_f_loop_2
	; limit > index
	inc e		;4
	jr z, _f_loop3	;7
_f_loop4
	ld (ix + 0), e	;15
	ld a, (bc)	;7
	ld e, a		;4
	inc bc		;6
	ld a, (bc)	;7
	ld b, a		;4
	ld c, e		;4
	jp _next	;10 + 29    179T for most of time     
_f_loop3
	inc d
	ld (ix + 1), d
	jr _f_loop4
_f_loop1
	ld de, 4
	add ix, de	;release loop structure at stack
	inc bc		;skip loop label
	inc bc
	jp _next		

_f_leave
	;leave loop
	inc ix
	inc ix
	inc ix
	inc ix
	ld a, (bc)
	inc bc
	ld e, a
	ld a, (bc)
	ld b, a
	ld c, e
	jp _next 


_f_do
	ld de, -4
	add ix, de
	ld (ix + 0), l	;index
	ld (ix + 1), h
	pop hl
	ld (ix + 2), l	;limit
	ld (ix + 3), h
	pop hl
	jp _next

_f_brzero
	ld a, l
	or h
	ld a, (bc)
	inc bc
	ld e, a
	ld a, (bc)
	inc bc
	pop hl
	jp nz, _next
_f_branch_1
	ld b, a
	ld c, e
	jp _next 	

_f_brnz
	ld a, l
	or h
	ld a, (bc)
	inc bc
	ld e, a
	ld a, (bc)
	inc bc
	pop hl
	jp z, _f_branch1
	jp _next

_f_i
	push hl
	ld l, (ix + 0)
	ld h, (ix + 1)
	jp _next

_f_j
	push hl
	ld l, (ix + 4)
	ld h, (ix + 5)
	jp _next

_f_and
	pop de
	ld a, d
	and h
	ld h, a
	ld a, e
	and l
	ld l, a
	jp _next

_f_or
	pop de
	ld a, d
	or h
	ld h, a
	ld a, e
	or l
	ld l, a
	jp _next

_f_xor
	pop de
_f_xor1
	ld a, d
	xor h
	ld h, a
	ld a, e
	xor l
	ld l, a
	jp _next

_f_not
	ld de, 65535
	jr _f_xor1

_f_eq
	pop de
	or a
	sbc hl, de
	ld hl, 0
	jp nz, _next
_f_eq1
	dec hl
	jp _next

_f_sign
	bit 7, h
	ld hl, 0
	jp z, _next
	jr _f_eq1

_f_neg
	ld a, l
	xor 255
	ld l, a
	ld a, h
	xor 255
	ld h, a
	inc hl
	jp _next

_f_less
`	pop de
	ex de, hl
_f_less2
	or a
	sbc hl, de	;x1 < x2  -->   (x1 - x2) < 0
	ld hl, 0
	jr nc, _f_less1
	dec hl
_f_less1
	jp _next

_f_more
	pop de  	;x1 > x2  -->   (x2 - x1) < 0
	jr _f_less2

_f_neq
	pop de
	or a
	sbc hl, de
	ld hl, 0
	jp nz, _next
	dec hl
	jp _next

_f_eqless
	pop de
        				